(* ===================================================
            (c) 2009-2014, TSX Software
   ===================================================
   File: uConfig.pas
   ---------------------------------------------------
   This unit holds program configuration
   =================================================== *)

unit uConfig;

interface

uses SysUtils, Classes, pxml;

type
  TProgramConfig = class(TPXMLDocument)
  private
    FResourceName: string;
    FStore: boolean;
    function RGetStr(XPath: string; DefValue: wideString): wideString;
    function RGetBool(XPath: string; DefValue: boolean): boolean;
    function RGetInt(XPath: string; DefValue: integer): integer;
    procedure RSetBool(XPath: string; DefValue: boolean;
      const Value: boolean);
    procedure RSetInt(XPath: string; DefValue: integer;
      const Value: integer);
    procedure RSetStr(XPath: string; DefValue: wideString; const Value: wideString);
    function GetNodeByName(XPath: string): TPXMLNode;
    function RGetDate(XPath: string; DefValue: TDateTime): TDateTime;
    procedure RSetDate(XPath: string; DefValue: TDateTime; const Value: TDateTime);
  protected
    function EvalPath(XPath: string): TPXMLNode;
  public
    constructor Create(AFile: string);
    destructor Destroy; override;

    procedure Commit;
    procedure Rollback;

    property NodeByName[XPath: string]: TPXMLNode read GetNodeByName;

    property AsString[XPath: string; DefValue: wideString]: wideString read RGetStr write RSetStr;
    property AsInteger[XPath: string; DefValue: integer]: integer read RGetInt write RSetInt;
    property AsBoolean[XPath: string; DefValue: boolean]: boolean read RGetBool write RSetBool;
    property AsDate[XPath: string; DefValue: TDateTime]: TDateTime read RGetDate write RSetDate;

    property SaveOnClose: boolean read FStore write FStore;
  end;

function Config: TProgramConfig;
procedure FreeConfig;

const CONF_FILENAME = 'config.coxml';

implementation

uses Variants;

var
  vConfig: TProgramConfig = nil;

function Config: TProgramConfig;
begin
  if (vConfig=nil) then
    vConfig := TProgramConfig.Create(IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)))+CONF_FILENAME);
  Result := vConfig;
end;

procedure FreeConfig();
begin
  if assigned(vConfig) then
    FreeAndNil(vConfig);
end;

function StrLPad(s: string; cnt: integer; cp: char): string;
begin
  Result := s;
  while cnt>0 do begin
    Result := cp+Result;
    Dec(cnt);
  end;
end;

{ TProgramConfig }

procedure TProgramConfig.Commit;
begin
  if FResourceName = '' then exit;
  Self.Save(FResourceName);
end;

constructor TProgramConfig.Create(AFile: string);
begin
  inherited Create();
  FResourceName := AFile;
  FStore := (AFile<>'');
  if FileExists(AFile) then inherited Load(AFile);

  if Self.DocumentRoot=nil then
    inherited LoadXML('<?xml version="1.0" encoding="UTF-8" ?><config />');
end;

destructor TProgramConfig.Destroy;
begin
  if FStore then Commit;
  inherited;
end;

function TProgramConfig.EvalPath(XPath: string): TPXMLNode;

    function _part: string;
    var ps: integer;
    begin
      ps := Pos('.',xpath);
      if ps < 1 then begin
        Result := xPath;
        xpath := '';
        exit;
      end else begin
        Result := copy(xpath,1,ps-1);
        delete(xpath,1,ps);
      end;
    end;

    function AllocateNode(ARoot: TPXMLNode; AName: wideString): TPXMLNode;
    begin
      Result := ARoot.FindChild(AName);
      if (Result=nil) then begin
        Result := TPXMLNode.Create(ARoot);
        Result.Name := AName;
      end;
    end;

var s: string;
begin
  Result := Self.DocumentRoot;
  if Result=nil then exit;

  while true do begin
    s := _part;
    if s = '' then break;
    Result := AllocateNode(Result, s)
  end;
end;

function TProgramConfig.GetNodeByName(XPath: string): TPXMLNode;
begin
  Result := EvalPath(XPath);
end;

function TProgramConfig.RGetBool(XPath: string; DefValue: boolean): boolean;
begin
  Result := StrToBoolDef(RGetStr(xPath, BoolToStr(defValue, true)), defValue);
end;

function TProgramConfig.RGetDate(XPath: string; DefValue: TDateTime): TDateTime;
var dt, ts: int64;
begin
  ts := int64(DateTimeToTimestamp(defValue));
  dt := EvalPath(xPath).getAttributeLL('value', ts);
  Result := TimeStampToDateTime(TTimeStamp(dt));
end;

function TProgramConfig.RGetInt(XPath: string; DefValue: integer): integer;
begin
  Result := EvalPath(xPath).getAttributeL('value', DefValue);
end;

function TProgramConfig.RGetStr(XPath: string; DefValue: wideString): wideString;
begin
  Result := EvalPath(XPath).getAttribute('value');
end;

procedure TProgramConfig.Rollback;
begin
  if FResourceName = '' then exit;
  DocumentRoot.ClearChilds;
  if FileExists(FResourceName) then inherited Load(FResourceName);
end;

procedure TProgramConfig.RSetBool(XPath: string; DefValue: boolean;
  const Value: boolean);
begin
  EvalPath(XPath).setAttribute('value', BoolToStr(Value, true));
end;

procedure TProgramConfig.RSetDate(XPath: string; DefValue: TDateTime; const Value: TDateTime);
begin
  EvalPath(XPath).setAttributeLL('value', int64(DateTimeToTimestamp(Value)));
end;

procedure TProgramConfig.RSetInt(XPath: string; DefValue: integer; const Value: integer);
begin
  EvalPath(XPath).setAttributeL('value', Value);
end;

procedure TProgramConfig.RSetStr(XPath: string; DefValue: wideString;
  const Value: wideString);
begin
  EvalPath(XPath).setAttribute('value', Value);
end;

initialization

finalization
  FreeConfig;
  
end.
